{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecursiveDo #-}

module App where

import GHCJS.DOM
import GHCJS.DOM.Types hiding (Text)
import GHCJS.DOM.Window (requestAnimationFrame)
import GHCJS.DOM.RequestAnimationFrameCallback (newRequestAnimationFrameCallback)
import GHCJS.DOM.Document hiding (click, load)
import GHCJS.DOM.Element (setAttribute, load)
import GHCJS.DOM.Node
import GHCJS.DOM.HTMLCanvasElement (getContext)
import GHCJS.DOM.WebGLRenderingContextBase

import Control.Monad.IO.Class (liftIO)

import GHCJS.Types
import GHCJS.Marshal
import JavaScript.TypedArray.Internal hiding (length)

import Linear
import Control.Lens

import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import Data.IORef (IORef, newIORef, writeIORef, readIORef, modifyIORef)
import Control.Monad

import Shader (initShader)

import GHCJS.DOM.HTMLImageElement (getSrc, setSrc)
import GHCJS.DOM.EventM(on, event)

import GHCJS.DOM.UIEvent (getKeyCode)

import Data.Bits ((.|.))
doubles2Float32ArrayJSVal :: [Double] -> IO JSVal
doubles2Float32ArrayJSVal xs = (jsval . js_float32ArrayFromJSVal) <$> toJSVal xs

m44ToList :: M44 a -> [a]
m44ToList (V4 x y z w) = concat $ v4ToList <$> [x, y, z, w]
  where v4ToList (V4 a b c d)= [a, b, c, d]

angle2radian :: Double -> Double
angle2radian x = pi * x / 180.0

foreign import javascript unsafe "console.log($1)"
  clg ::JSVal -> IO ()

foreign import javascript unsafe "$1.BYTES_PER_ELEMENT"
  js_size :: JSVal -> Int

animate :: IORef Double  -- 保存当前degree值
        -> IORef UTCTime  -- hold current time value
        -> Double         -- rotate degree per 1 sec
        -> IO Double
animate x time step = do
  ang <- readIORef x
  now <- getCurrentTime
  l <- readIORef time
  writeIORef time now
  let afterStep = ang + realToFrac (diffUTCTime now l) * step
  writeIORef x afterStep
  pure afterStep

initGL :: Window -> IO WebGLRenderingContextBase
initGL win = do
  enableInspector win
  Just doc <- webViewGetDomDocument win
  Just body <- getBody doc
  Just canvas <- fmap castToHTMLCanvasElement <$> createElement doc (Just "canvas")
  setAttribute (toElement canvas) "width" "400"
  setAttribute (toElement canvas) "height" "400"
  _ <- appendChild body (Just canvas)
  WebGLRenderingContextBase <$> getContext canvas "webgl"

app :: IO ()
app = runWebGUI $ \win -> do
  gl <- initGL win
  program <- initShader gl
  -- maybe shader invalid
  mErr :: Maybe String<- getProgramInfoLog gl program
  liftIO $ print mErr

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  let n = 3
      vertics = [0.0, 0.5, -0.5, -0.5, 0.5, -0.5]

  xformMatrix <- getUniformLocation gl program "u_ModelMatrix"

  vertVal <- doubles2Float32ArrayJSVal vertics
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer vertVal) STATIC_DRAW
  vertexAttribPointer gl aPosition 2 FLOAT False 0 0
  enableVertexAttribArray gl aPosition

  cAngle <- newIORef 0.0
  nowTime <- newIORef =<< getCurrentTime
  let draw currentRadian = do

        let m = transpose $ m33_to_m44 (fromQuaternion (axisAngle (V3 0 0 1) currentRadian)) !*! (identity & translation .~ V3 0.35 0.0 0.0)

        tm <- doubles2Float32ArrayJSVal $ m44ToList m
        uniformMatrix4fv gl xformMatrix False (Just $ Float32Array tm)
        clear gl COLOR_BUFFER_BIT
        drawArrays gl TRIANGLES 0 n

      step = 45.0
      go = do
        rec cb <- newRequestAnimationFrameCallback $ \_ -> do
              currentAngle <- animate cAngle nowTime step
              draw (angle2radian currentAngle)
              void next

            let next = requestAnimationFrame win (Just cb)

        void next

  clearColor gl 0.0 0.0 0.0 1.0
  go

app2 :: IO ()
app2 = runWebGUI $ \win -> do
  gl <- initGL win
  program <- initShader gl
  print =<< getError gl
  let vertics =
        [ 0.0, 0.5, 1.0, 0.0, 0.0
        , -0.5, -0.5, 0.0, 1.0, 0.0
        , 0.5, -0.5, 0.0, 0.0, 1.0]
      n = 3

  verticsJ <- doubles2Float32ArrayJSVal vertics
  v' <- js_float32ArrayFromJSVal <$> toJSVal vertics

  -- fsize = 4
  --let fsize = fromIntegral $ js_size verticsJ
  let fsize = fromIntegral $ elemSize v'
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer verticsJ) STATIC_DRAW

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  vertexAttribPointer gl aPosition 2 FLOAT False (fsize * 5) 0
  enableVertexAttribArray gl aPosition

  aColor <- fromIntegral <$> getAttribLocation gl program "a_Color"
  vertexAttribPointer gl aColor 3 FLOAT False (fsize * 5) (fromIntegral fsize * 2)
  enableVertexAttribArray gl aColor

  clearColor gl 0.0 0.0 0.0 1.0
  clear gl COLOR_BUFFER_BIT
  drawArrays gl TRIANGLES 0 n

app3 :: IO ()
app3 = runWebGUI $ \win -> do
  gl <- initGL win
  program <- initShader gl
  let vertics =
        [ 0.0, 0.5, -0.5, -0.5, 0.5, -0.5]
      n = 3
  verticsJ <- doubles2Float32ArrayJSVal vertics
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer verticsJ) STATIC_DRAW

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  vertexAttribPointer gl aPosition 2 FLOAT False 0 0
  enableVertexAttribArray gl aPosition

  uWidth <- getUniformLocation gl program "u_Width"
  uHeight <- getUniformLocation gl program "u_Height"
  fromIntegral <$> getDrawingBufferWidth gl >>= uniform1f gl uWidth
  fromIntegral <$> getDrawingBufferHeight gl >>= uniform1f gl uHeight

  clearColor gl 0.0 0.0 0.0 1.0
  clear gl COLOR_BUFFER_BIT
  drawArrays gl TRIANGLES 0 n

app4 :: IO ()
app4 = runWebGUI $ \win -> do
  gl <- initGL win
  Just doc <- webViewGetDomDocument win
  program <- initShader gl
  print =<< getError gl
  let vertics =
        [ -0.5, 0.5, 0.0, 1.0 -- V2顶点 V2纹理
        , -0.5, -0.5, 0.0, 0.0
        , 0.5, 0.5, 1.0, 1.0
        , 0.5, -0.5, 1.0, 0.0]
      n = 4
      fsize = 4
  verticsJ <- doubles2Float32ArrayJSVal vertics
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer verticsJ) STATIC_DRAW

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  vertexAttribPointer gl aPosition 2 FLOAT False (fsize * 4) 0
  enableVertexAttribArray gl aPosition

  aTexCoord <- fromIntegral <$> getAttribLocation gl program "a_TexCoord"
  vertexAttribPointer gl aTexCoord 2 FLOAT False (fsize * 4) (fromIntegral fsize * 2)
  enableVertexAttribArray gl aTexCoord

  -- Texture
  texture <- createTexture gl
  uSampler <- getUniformLocation gl program "u_Sampler"
  texture2 <- createTexture gl
  uSampler2 <- getUniformLocation gl program "u_Sampler2"
  is1Ready <- newIORef False
  is2Ready <- newIORef False
  let loadTexture tex sample imgElm texNum = do
        if texNum == 0
           then activeTexture gl TEXTURE0 >> liftIO (writeIORef is1Ready True)
           else activeTexture gl TEXTURE1 >> liftIO (writeIORef is2Ready True)
        pixelStorei gl UNPACK_FLIP_Y_WEBGL 1 -- 对纹理进行Y轴反转
        bindTexture gl TEXTURE_2D tex -- 向target绑定纹理对象
        texParameteri gl TEXTURE_2D TEXTURE_MIN_FILTER LINEAR
        texImage2D gl TEXTURE_2D 0 RGB RGB UNSIGNED_BYTE imgElm
        uniform1i gl sample texNum

        state1 <- liftIO $ readIORef is1Ready
        state2 <- liftIO $ readIORef is2Ready
        liftIO $ do
          print state1
          print state2
        if state1 && state2
           then do
              clearColor gl 0.0 0.0 0.0 1.0
              clear gl COLOR_BUFFER_BIT
              drawArrays gl TRIANGLE_STRIP 0 n
           else pure ()

  Just img <- fmap castToHTMLImageElement <$> createElement doc (Just "img")
  _ <- img `on` load $ loadTexture texture uSampler (Just img) 0
  Just img2 <- fmap castToHTMLImageElement <$> createElement doc (Just "img")
  _ <- img2 `on` load $ loadTexture texture2 uSampler2 (Just img2) 1
  setSrc img "./sky.jpg"
  setSrc img2 "./circle.gif"

app5 :: IO ()
app5 = runWebGUI $ \win -> do
  gl <- initGL win
  Just doc <- webViewGetDomDocument win
  program <- initShader gl
  let verticsAndColors =
        [ 0.0, 0.5, -0.4, 0.4, 1.0, 0.4 --三个一组
        , -0.5, -0.5, -0.4, 0.4, 1.0, 0.4
        , 0.5, -0.5, -0.4, 1.0, 0.4, 0.4
        , 0.5, 0.4, -0.2, 1.0, 0.4, 0.4
        , -0.5, 0.4, -0.2, 1.0, 1.0, 0.4
        , 0.0, -0.6, -0.2, 1.0, 1.0, 0.4
        , 0.0, 0.5, 0.0, 0.4, 0.4, 1.0
        , -0.5, -0.5, 0.0, 0.4, 0.4, 1.0
        , 0.5, -0.5, 0.0, 1.0, 0.4, 0.4]
      n = 9
      fsize = 4

  verticsJ <- doubles2Float32ArrayJSVal verticsAndColors
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer verticsJ) STATIC_DRAW

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  aColor <- fromIntegral <$> getAttribLocation gl program "a_Color"
  vertexAttribPointer gl aPosition 3 FLOAT False (fsize * 6) 0
  vertexAttribPointer gl aColor 3 FLOAT False (fsize * 6) (fromIntegral fsize * 3)
  enableVertexAttribArray gl aPosition
  enableVertexAttribArray gl aColor

  uModelViewMatrix <- getUniformLocation gl program "u_ModelViewMatrix"
  eyeX <- newIORef 0.0
  near <- newIORef 0.0
  let draw = do
        x <- readIORef eyeX
        near' <- readIORef near
        liftIO $ print near'
        let viewMat = transpose $ ortho (-0.5) 0.5 (-0.5) 0.5 near' 0.5 !*! lookAt (V3 x 0.0 0.2) (V3 0 0 0) (V3 0 1 0)
        viewMatJ <- doubles2Float32ArrayJSVal $ m44ToList viewMat
        uniformMatrix4fv gl uModelViewMatrix False (Just $ Float32Array viewMatJ)
        clearColor gl 0.0 0.0 0.0 1.0
        clear gl COLOR_BUFFER_BIT
        drawArrays gl TRIANGLES 0 n

  _ <- doc `on` keyDown $ do
          ev <- event
          kc <- getKeyCode ev
          case kc of
            39 -> liftIO $ modifyIORef eyeX (+ 0.01)
            37 -> liftIO $ modifyIORef eyeX (subtract 0.01)
            38 -> liftIO $ modifyIORef near (+ 0.01)
            40 -> liftIO $ modifyIORef near (subtract 0.01)
            _ -> pure ()
          liftIO draw

  draw

app6 :: IO ()
app6 = runWebGUI $ \win -> do
  gl <- initGL win
  program <- initShader gl
  let vertics =
        [
          0.0, 1.0, 0.0, 0.4, 0.4, 1.0
        , -0.5, -1.0, 0.0, 0.4, 0.4, 1.0
        , 0.5, -1.0, 0.0, 1.0, 0.4, 0.4
        , 0.0, 1.0, -2.0, 1.0, 1.0, 0.4
        , -0.5, -1.0, -2.0, 1.0, 1.0, 0.4
        , 0.5, -1.0, -2.0, 1.0, 0.4, 0.4
        , 0.0, 1.0, -4.0, 0.4, 1.0, 0.4
        , -0.5, -1.0, -4.0, 0.4, 1.0, 0.4
        , 0.5, -1.0, -4.0, 1.0, 0.4, 0.4
        ]
      n = 9
      fsize = 4

  verticsJ <- doubles2Float32ArrayJSVal vertics
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer verticsJ) STATIC_DRAW

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  aColor <- fromIntegral <$> getAttribLocation gl program "a_Color"
  vertexAttribPointer gl aPosition 3 FLOAT False (fsize * 6) 0
  vertexAttribPointer gl aColor 3 FLOAT False (fsize * 6) (fromIntegral fsize * 3)
  enableVertexAttribArray gl aPosition
  enableVertexAttribArray gl aColor

  uMvp <- getUniformLocation gl program "u_MvpMatrix"
  let vpMatrix = perspective (angle2radian 30.0) 1 1 100 !*! lookAt (V3 0 0 5) (V3 0 0 (-100)) (V3 0 1 0)
      rightModel = identity & translation .~ V3 0.75 0 0
      leftModel = identity & translation .~ V3 (-0.75) 0 0

  rMatrix <- doubles2Float32ArrayJSVal . m44ToList . transpose $ vpMatrix !*! rightModel
  lMatrix <- doubles2Float32ArrayJSVal . m44ToList . transpose $ vpMatrix !*! leftModel
  clearColor gl 0.0 0.0 0.0 1.0
  enable gl DEPTH_TEST
  clear gl (COLOR_BUFFER_BIT .|. DEPTH_BUFFER_BIT)
  uniformMatrix4fv gl uMvp False (Just $ Float32Array rMatrix)
  drawArrays gl TRIANGLES 0 n
  uniformMatrix4fv gl uMvp False (Just $ Float32Array lMatrix)
  drawArrays gl TRIANGLES 0 n

cube :: IO ()
cube = runWebGUI $ \win -> do
  gl <- initGL win
  program <- initShader gl
  let vertics = [
        1.0, 1.0, 1.0, 1.0, 1.0, 1.0,
        -1.0, 1.0, 1.0, 1.0, 0.0, 1.0,
        -1.0, -1.0, 1.0, 1.0, 0.0, 0.0,
        1.0, -1.0, 1.0, 1.0, 1.0, 0.0,
        1.0, -1.0, -1.0, 0.0, 1.0, 0.0,
        1.0, 1.0, -1.0, 0.0, 1.0, 1.0,
        -1.0, 1.0, -1.0, 0.0, 0.0, 1.0,
        -1.0, -1.0, -1.0, 0.0, 0.0, 0.0]
      --n = 8
      fsize = 4
      indices = [ 0, 1, 2, 0, 2, 3
        , 0, 3, 4, 0, 4, 5
        , 0, 5, 6, 0, 6, 1
        , 1, 6, 7, 1, 7, 2
        , 7, 4, 3, 7, 3, 2
        , 4, 7, 6, 4, 6, 5]

  verticsJ <- doubles2Float32ArrayJSVal vertics
  vbo <- createBuffer gl
  bindBuffer gl ARRAY_BUFFER vbo
  bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer verticsJ) STATIC_DRAW

  let ints2Uint8Array :: [Int] -> IO JSVal
      ints2Uint8Array xs =  (jsval . js_uint8ArrayFromJSVal) <$> toJSVal xs
  indicesJ <- ints2Uint8Array indices
  ibo <- createBuffer gl
  bindBuffer gl ELEMENT_ARRAY_BUFFER ibo
  bufferData gl ELEMENT_ARRAY_BUFFER (Just $ ArrayBuffer indicesJ) STATIC_DRAW

  aPosition <- fromIntegral <$> getAttribLocation gl program "a_Position"
  aColor <- fromIntegral <$> getAttribLocation gl program "a_Color"
  vertexAttribPointer gl aPosition 3 FLOAT False (fsize * 6) 0
  vertexAttribPointer gl aColor 3 FLOAT False (fsize * 6) (fromIntegral fsize * 3)
  enableVertexAttribArray gl aPosition
  enableVertexAttribArray gl aColor

  uMvp <- getUniformLocation gl program "u_MvpMatrix"
  let mvpMat = perspective (angle2radian 30.0) 1 1 100 !*! lookAt (V3 3 3 7) (V3 0 0 0) (V3 0 1 0)

  mvpMatJ <- doubles2Float32ArrayJSVal . m44ToList . transpose $ mvpMat
  uniformMatrix4fv gl uMvp False (Just $ Float32Array mvpMatJ)
  enable gl DEPTH_TEST
  clearColor gl 0.0 0.0 0.0 1.0
  clear gl (COLOR_BUFFER_BIT .|. DEPTH_BUFFER_BIT)
  drawElements gl TRIANGLES (fromIntegral $ length indices) UNSIGNED_BYTE 0

colorCube :: IO ()
colorCube = runWebGUI $ \win -> do
  gl <- initGL win
  program <- initShader gl
  let vertics = [
        1.0, 1.0, 1.0,  -1.0, 1.0, 1.0,  -1.0,-1.0, 1.0,   1.0,-1.0, 1.0,
        1.0, 1.0, 1.0,   1.0,-1.0, 1.0,   1.0,-1.0,-1.0,   1.0, 1.0,-1.0,
        1.0, 1.0, 1.0,   1.0, 1.0,-1.0,  -1.0, 1.0,-1.0,  -1.0, 1.0, 1.0,
        -1.0, 1.0, 1.0,  -1.0, 1.0,-1.0,  -1.0,-1.0,-1.0,  -1.0,-1.0, 1.0,
        -1.0,-1.0,-1.0,   1.0,-1.0,-1.0,   1.0,-1.0, 1.0,  -1.0,-1.0, 1.0,
        1.0,-1.0,-1.0,  -1.0,-1.0,-1.0,  -1.0, 1.0,-1.0,   1.0, 1.0,-1.0]
      colors = [
        0.4, 0.4, 1.0,  0.4, 0.4, 1.0,  0.4, 0.4, 1.0,  0.4, 0.4, 1.0,
        0.4, 1.0, 0.4,  0.4, 1.0, 0.4,  0.4, 1.0, 0.4,  0.4, 1.0, 0.4,
        1.0, 0.4, 0.4,  1.0, 0.4, 0.4,  1.0, 0.4, 0.4,  1.0, 0.4, 0.4,
        1.0, 1.0, 0.4,  1.0, 1.0, 0.4,  1.0, 1.0, 0.4,  1.0, 1.0, 0.4,
        1.0, 1.0, 1.0,  1.0, 1.0, 1.0,  1.0, 1.0, 1.0,  1.0, 1.0, 1.0,
        0.4, 1.0, 1.0,  0.4, 1.0, 1.0,  0.4, 1.0, 1.0,  0.4, 1.0, 1.0]
      --fsize = 4
      indices = [
        0, 1, 2,   0, 2, 3,
        4, 5, 6,   4, 6, 7,
        8, 9,10,   8,10,11,
        12,13,14,  12,14,15,
        16,17,18,  16,18,19,
        20,21,22,  20,22,23]

  let initArrayBuffer vert name = do
        vertJ <- doubles2Float32ArrayJSVal vert
        ab <- createBuffer gl
        bindBuffer gl ARRAY_BUFFER ab
        bufferData gl ARRAY_BUFFER (Just $ ArrayBuffer vertJ) STATIC_DRAW
        pos <- fromIntegral <$> getAttribLocation gl program name
        vertexAttribPointer gl pos 3 FLOAT False 0 0
        enableVertexAttribArray gl pos
  initArrayBuffer vertics "a_Position"
  initArrayBuffer colors "a_Color"

  let ints2Uint8Array :: [Int] -> IO JSVal
      ints2Uint8Array xs =  (jsval . js_uint8ArrayFromJSVal) <$> toJSVal xs
  indicesJ <- ints2Uint8Array indices
  ibo <- createBuffer gl
  bindBuffer gl ELEMENT_ARRAY_BUFFER ibo
  bufferData gl ELEMENT_ARRAY_BUFFER (Just $ ArrayBuffer indicesJ) STATIC_DRAW

  uMvp <- getUniformLocation gl program "u_MvpMatrix"
  let mvpMat = perspective (angle2radian 30.0) 1 1 100 !*! lookAt (V3 3 3 7) (V3 0 0 0) (V3 0 1 0)

  mvpMatJ <- doubles2Float32ArrayJSVal . m44ToList . transpose $ mvpMat
  uniformMatrix4fv gl uMvp False (Just $ Float32Array mvpMatJ)
  enable gl DEPTH_TEST
  clearColor gl 0.0 0.0 0.0 1.0
  clear gl (COLOR_BUFFER_BIT .|. DEPTH_BUFFER_BIT)
  drawElements gl TRIANGLES (fromIntegral $ length indices) UNSIGNED_BYTE 0
